home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Snippets / PNL Libraries / MyBinHex.p < prev    next >
Text File  |  1996-10-21  |  12KB  |  484 lines
  1. unit MyBinHex;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Files;
  7.  
  8.     const
  9.         notEnoughData = 1;
  10.  
  11.     type
  12.         BinHexEncodeState = record
  13.                 state: integer;
  14.                 bits: integer;
  15.                 repcnt, lastbyte: integer;
  16.                 linepos: integer;
  17.                 dlen, rlen: longint;
  18.                 crc: integer;
  19.                 crlf: boolean;
  20.                 datafork: boolean;
  21.             end;
  22.  
  23.     procedure StartupBinHex;
  24.     procedure BinHexEncodeStart (var bh: BinHexEncodeState; crlf: boolean; name: Str63; var fi: FInfo; dlen, rlen: longint; p: Ptr; len: longint; var count: longint);
  25.     procedure BinHexEncodeChunk (var bh: BinHexEncodeState; p: Ptr; len: longint; var count: longint; eofork, eofile: boolean);
  26.     function BinHexDecodeStart (var bh: BinHexEncodeState; var name: Str63; var fi: FInfo; var dlen, rlen: longint; p: Ptr; len: longint; var count: longint): OSErr;
  27.     function BinHexDecodeChunk (var bh: BinHexEncodeState; inp: Ptr; inlen: longint; var inused: longint; outp: Ptr; outlen: longint; var outused: longint; var eofork, eofile: boolean): OSErr;
  28.  
  29. implementation
  30.  
  31.     uses
  32.         Memory, CalcCRC, MyLowLevel, MyStartup;
  33.  
  34.     const
  35.         binhex_start_string_hack = '(This file must be converted with BinHex 4.0)';
  36.         binhex_check_length = 33;
  37.         first_binhex_char = ord('(');
  38.         second_binhex_char = ord('T');
  39.         mapbc_hack = '!"#$%&''()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr';
  40.         rep = $90;
  41.         dud_byte = $FF;
  42.  
  43.     var
  44.         mapbc: string[64];
  45.         binhex_start_string:string[63];
  46.         map: packed array[0..255] of Byte;
  47.  
  48.     procedure BinHexEncodeStart (var bh: BinHexEncodeState; crlf: boolean; name: Str63; var fi: FInfo; dlen, rlen: longint; p: Ptr; len: longint; var count: longint);
  49.         var
  50.             headerlen: integer;
  51.             q: Ptr;
  52.             s: Str255;
  53.     begin
  54.         q := p;
  55.         s := binhex_start_string;
  56.         BlockMoveData(@s[1], q, length(s));
  57.         OffsetPtr(q, length(s));
  58.         q^ := 13;
  59.         OffsetPtr(q, 1);
  60.         if crlf then begin
  61.             q^ := 10;
  62.             OffsetPtr(q, 1);
  63.         end;
  64.         q^ := ord(':');
  65.         OffsetPtr(q, 1);
  66.         headerlen := SubPtrPtr(q, p);
  67.         p := q;
  68.         BlockMoveData(@name, q, length(name) + 1);
  69.         OffsetPtr(q, length(name) + 1);
  70.         q^ := 0;
  71.         OffsetPtr(q, 1);
  72.         BlockMoveData(@fi.fdType, q, 4);
  73.         OffsetPtr(q, 4);
  74.         BlockMoveData(@fi.fdCreator, q, 4);
  75.         OffsetPtr(q, 4);
  76.         BlockMoveData(@fi.fdFlags, q, 2);
  77.         OffsetPtr(q, 2);
  78.         BlockMoveData(@dlen, q, 4);
  79.         OffsetPtr(q, 4);
  80.         BlockMoveData(@rlen, q, 4);
  81.         OffsetPtr(q, 4);
  82.         count := SubPtrPtr(q, p);
  83.         bh.state := 0;
  84.         bh.bits := 0;
  85.         bh.linepos := 1;
  86.         bh.crc := 0;
  87.         bh.crlf := crlf;
  88.         BinHexEncodeChunk(bh, p, len - headerlen, count, true, false);
  89.         count := count + headerlen;
  90.     end;
  91.  
  92.     procedure BinHexEncodeChunk (var bh: BinHexEncodeState; p: Ptr; len: longint; var count: longint; eofork, eofile: boolean);
  93. { p & len may be odd, count is in/out }
  94.         var
  95.             c, newcount: longint;
  96.             src, dst: Ptr;
  97.             b1, b2, b3: integer;
  98.     begin
  99.         CalcMBCRCBlock(p, count, bh.crc);
  100.         if eofork then begin
  101.             BlockMoveData(@bh.crc, AddPtrLong(p, count), 2);
  102.             count := count + 2;
  103.             bh.crc := 0;
  104.         end;
  105.         if count > 0 then begin
  106.             dst := AddPtrLong(p, len);
  107.             src := AddPtrLong(p, count);
  108. { First RLE encode (ie, change $90 to $90,$00) }
  109.             newcount := 0;
  110.             for c := 1 to count do begin
  111.                 OffsetPtr(src, -1);
  112.                 if BAND(src^, $FF) = rep then begin
  113.                     OffsetPtr(dst, -1);
  114.                     dst^ := 0;
  115.                     newcount := newcount + 1;
  116.                 end;
  117.                 OffsetPtr(dst, -1);
  118.                 dst^ := src^;
  119.                 newcount := newcount + 1;
  120.             end;
  121. { Then enhqx }
  122.             src := dst;
  123.             dst := p;
  124.             count := 0;
  125.             while newcount > 0 do begin
  126.                 case bh.state of
  127.                     0:  begin
  128.                         while (newcount >= 3) & (bh.linepos < 60) do begin
  129.                             b1 := src^;
  130.                             OffsetPtr(src, 1);
  131.                             b2 := src^;
  132.                             OffsetPtr(src, 1);
  133.                             b3 := src^;
  134.                             OffsetPtr(src, 1);
  135.                             dst^ := SignedByte(mapbc[BAND(BSR(b1, 2), $3F) + 1]);
  136.                             OffsetPtr(dst, 1);
  137.                             dst^ := SignedByte(mapbc[BAND(BOR(BSL(b1, 4), BAND(BSR(b2, 4), $0F)), $3F) + 1]);
  138.                             OffsetPtr(dst, 1);
  139.                             dst^ := SignedByte(mapbc[BAND(BOR(BSL(b2, 2), BAND(BSR(b3, 6), $03)), $3F) + 1]);
  140.                             OffsetPtr(dst, 1);
  141.                             dst^ := SignedByte(mapbc[BAND(b3, $3F) + 1]);
  142.                             OffsetPtr(dst, 1);
  143.                             newcount := newcount - 3;
  144.                             bh.linepos := bh.linepos + 4;
  145.                             count := count + 4;
  146.                         end;
  147.                         if newcount > 0 then begin
  148.                             b1 := src^;
  149.                             OffsetPtr(src, 1);
  150.                             dst^ := SignedByte(mapbc[BAND(BSR(b1, 2), $3F) + 1]);
  151.                             OffsetPtr(dst, 1);
  152.                             bh.bits := b1;
  153.                             newcount := newcount - 1;
  154.                             bh.linepos := bh.linepos + 1;
  155.                             count := count + 1;
  156.                             bh.state := 2;
  157.                         end;
  158.                     end;
  159.                     2:  begin
  160.                         b2 := src^;
  161.                         OffsetPtr(src, 1);
  162.                         dst^ := SignedByte(mapbc[BAND(BOR(BSL(bh.bits, 4), BAND(BSR(b2, 4), $0F)), $3F) + 1]);
  163.                         OffsetPtr(dst, 1);
  164.                         bh.bits := b2;
  165.                         newcount := newcount - 1;
  166.                         bh.linepos := bh.linepos + 1;
  167.                         count := count + 1;
  168.                         bh.state := 4;
  169.                     end;
  170.                     4:  begin
  171.                         b3 := src^;
  172.                         OffsetPtr(src, 1);
  173.                         dst^ := SignedByte(mapbc[BAND(BOR(BSL(bh.bits, 2), BAND(BSR(b3, 6), $03)), $3F) + 1]);
  174.                         OffsetPtr(dst, 1);
  175.                         bh.linepos := bh.linepos + 2;
  176.                         if bh.linepos > 64 then begin
  177.                             dst^ := 13;
  178.                             OffsetPtr(dst, 1);
  179.                             count := count + 1;
  180.                             if bh.crlf then begin
  181.                                 dst^ := 10;
  182.                                 OffsetPtr(dst, 1);
  183.                                 count := count + 1;
  184.                             end;
  185.                             bh.linepos := 1;
  186.                         end;
  187.                         dst^ := SignedByte(mapbc[BAND(b3, $3F) + 1]);
  188.                         OffsetPtr(dst, 1);
  189.                         newcount := newcount - 1;
  190.                         count := count + 2;
  191.                         bh.state := 0;
  192.                     end;
  193.                 end;
  194.             end;
  195.         end;
  196.         if eofile then begin
  197.             case bh.state of
  198.                 0:  begin
  199.                 end;
  200.                 2:  begin
  201.                     dst^ := SignedByte(mapbc[BAND(BSL(bh.bits, 4), $3F) + 1]);
  202.                     OffsetPtr(dst, 1);
  203.                     count := count + 1;
  204.                 end;
  205.                 4:  begin
  206.                     dst^ := SignedByte(mapbc[BAND(BSL(bh.bits, 2), $3F) + 1]);
  207.                     OffsetPtr(dst, 1);
  208.                     count := count + 1;
  209.                 end;
  210.             end;
  211.             dst^ := ord(':');
  212.             OffsetPtr(dst, 1);
  213.             dst^ := 13;
  214.             OffsetPtr(dst, 1);
  215.             count := count + 2;
  216.             if bh.crlf then begin
  217.                 dst^ := 10;
  218.                 OffsetPtr(dst, 1);
  219.                 count := count + 1;
  220.             end;
  221.         end;
  222.     end;
  223.  
  224.     procedure BHGetByte (var bh: BinHexEncodeState; p: Ptr; len: longint; var count: longint; var err: OSErr; var n: integer);
  225.         procedure GB (var n: integer);
  226.             label
  227.                 1;
  228.             var
  229.                 b: integer;
  230.         begin
  231.             if err = noErr then begin
  232. 1:
  233.                 while (count < len) & (AddPtrLong(p, count)^ < 32) do begin
  234.                     count := count + 1;
  235.                 end;
  236.                 if count >= len then begin
  237.                     err := notEnoughData;
  238.                 end else begin
  239.                     b := map[BAND(AddPtrLong(p, count)^, $FF)];
  240.                     count := count + 1;
  241.                     if b = dud_byte then begin
  242.                         err := -3;
  243.                     end else begin
  244.                         case bh.state of
  245.                             0:  begin
  246.                                 bh.bits := b;
  247.                                 bh.state := 1;
  248.                                 goto 1;
  249.                             end;
  250.                             1:  begin
  251.                                 n := BOR(BSL(bh.bits, 2), BAND(BSR(b, 4), $03));
  252.                                 bh.bits := b;
  253.                                 bh.state := 2;
  254.                             end;
  255.                             2:  begin
  256.                                 n := BOR(BSL(bh.bits, 4), BAND(BSR(b, 2), $0F));
  257.                                 bh.bits := b;
  258.                                 bh.state := 3;
  259.                             end;
  260.                             3:  begin
  261.                                 n := BOR(BSL(bh.bits, 6), BAND(b, $3F));
  262.                                 bh.state := 0;
  263.                             end;
  264.                         end;
  265.                         n := BAND(n, $FF);
  266.                     end;
  267.                 end;
  268.             end;
  269.         end;
  270.  
  271.         label
  272.             1;
  273.         var
  274.             c: integer;
  275.             oldstate: BinHexEncodeState;
  276.             oldcount: longint;
  277.     begin
  278. 1:
  279.         if err = noErr then begin
  280.             oldstate := bh;
  281.             oldcount := count;
  282.             if bh.repcnt > 0 then begin
  283.                 n := bh.lastbyte;
  284.                 bh.repcnt := bh.repcnt - 1;
  285.             end else begin
  286.                 GB(n);
  287.                 if (err = noErr) & (n = rep) then begin
  288.                     GB(c);
  289.                     if err = noErr then begin
  290.                         case c of
  291.                             0: 
  292.                                 ; { Do nothing, pass back the literal rep }
  293.                             1: 
  294.                                 goto 1; { Pretty damn stupid to have a rep count of 1 }
  295.                             otherwise begin
  296.                                 n := bh.lastbyte;
  297.                                 bh.repcnt := c - 2;
  298.                             end;
  299.                         end;
  300.                     end;
  301.                 end;
  302.             end;
  303.             if err = notEnoughData then begin
  304.                 bh := oldstate;
  305.                 count := oldcount;
  306.             end else begin
  307.                 CalcMBCRC(bh.crc, n);
  308.                 bh.lastbyte := n;
  309.             end;
  310.         end;
  311.     end;
  312.  
  313.     function BinHexDecodeStart (var bh: BinHexEncodeState; var name: Str63; var fi: FInfo; var dlen, rlen: longint; p: Ptr; len: longint; var count: longint): OSErr;
  314.         var
  315.             err: OSErr;
  316.  
  317.         procedure GetByte (var n: integer);
  318.         begin
  319.             BHGetByte(bh, p, len, count, err, n);
  320.         end;
  321.  
  322.         procedure GetInteger (var x: univ integer);
  323.             var
  324.                 n, i: integer;
  325.         begin
  326.             x := 0;
  327.             for i := 1 to 2 do begin
  328.                 GetByte(n);
  329.                 x := BOR(BSL(x, 8), n);
  330.             end;
  331.         end;
  332.  
  333.         procedure GetLong (var x: univ longint);
  334.             var
  335.                 n, i: integer;
  336.         begin
  337.             x := 0;
  338.             for i := 1 to 4 do begin
  339.                 GetByte(n);
  340.                 x := BOR(BSL(x, 8), n);
  341.             end;
  342.         end;
  343.  
  344.         var
  345.             namelen, n, i: integer;
  346.             thecrc, realcrc: integer;
  347.     begin
  348.         err := notEnoughData;
  349.         count := 0;
  350.         while count < len - binhex_check_length do begin
  351.             if AddPtrLong(p, count)^ = first_binhex_char then begin
  352.                 if AddPtrLong(p, count + 1)^ = second_binhex_char then begin
  353.                     i := 3;
  354.                     while (i <= binhex_check_length) and (AddPtrLong(p, count + i - 1)^ = ord(binhex_start_string[i])) do begin
  355.                         i := i + 1;
  356.                     end;
  357.                     if i > binhex_check_length then begin
  358.                         err := noErr;
  359.                         leave;
  360.                     end;
  361.                 end;
  362.             end;
  363.             count := count + 1;
  364.         end;
  365.         if err = noErr then begin
  366.             count := count + binhex_check_length;
  367.             while (count < len) & (AddPtrLong(p, count)^ >= 32) do begin
  368.                 count := count + 1;
  369.             end;
  370.             while (count < len) & (AddPtrLong(p, count)^ <= 32) do begin
  371.                 count := count + 1;
  372.             end;
  373.             if count >= len then begin
  374.                 err := notEnoughData;
  375.             end else if (AddPtrLong(p, count)^ <> ord(':')) then begin
  376.                 err := -73;
  377.             end else begin
  378.                 count := count + 1;
  379.             end;
  380.         end;
  381.         if err = noErr then begin
  382.             bh.state := 0;
  383.             bh.repcnt := 0;
  384.             bh.crc := 0;
  385.             GetByte(namelen);
  386.             if (err = noErr) & ((namelen <= 0) | (namelen > 63)) then begin
  387.                 err := -4;
  388.             end;
  389.         end;
  390.         if (err = noErr) then begin
  391.             name[0] := chr(namelen);
  392.             if (err = noErr) then begin
  393.                 for i := 1 to namelen do begin
  394.                     GetByte(n);
  395.                     name[i] := chr(n);
  396.                 end;
  397.             end;
  398.             GetByte(n);
  399.             if (err = noErr) & (n <> 0) then begin
  400.                 err := -5;
  401.             end;
  402.             GetLong(fi.fdType);
  403.             GetLong(fi.fdCreator);
  404.             GetInteger(fi.fdFlags);
  405.             GetLong(dlen);
  406.             bh.dlen := dlen;
  407.             GetLong(rlen);
  408.             bh.rlen := rlen;
  409.             realcrc := bh.crc;
  410.             GetInteger(thecrc);
  411.             bh.crc := 0;
  412.             bh.datafork := true;
  413.             if (err = noErr) & ((dlen < 0) | (dlen > $10000000) | (rlen < 0) | (rlen > $10000000) | (thecrc <> realcrc)) then begin
  414.                 err := -6;
  415.             end;
  416.         end;
  417.         BinHexDecodeStart := err;
  418.     end;
  419.  
  420.     function BinHexDecodeChunk (var bh: BinHexEncodeState; inp: Ptr; inlen: longint; var inused: longint; outp: Ptr; outlen: longint; var outused: longint; var eofork, eofile: boolean): OSErr;
  421.         var
  422.             err: OSErr;
  423.             n, h, l: integer;
  424.             oldinused: longint;
  425.             oldstate: BinHexEncodeState;
  426.             realcrc, thecrc: integer;
  427.     begin
  428.         err := noErr;
  429.         inused := 0;
  430.         outused := 0;
  431.         eofork := false;
  432.         eofile := false;
  433.         while (err = noErr) & (bh.dlen > 0) & (outused < outlen) do begin
  434.             BHGetByte(bh, inp, inlen, inused, err, n);
  435.             if err = noErr then begin
  436.                 bh.dlen := bh.dlen - 1;
  437.                 AddPtrLong(outp, outused)^ := n;
  438.                 outused := outused + 1;
  439.             end;
  440.         end;
  441.         if (err = noErr) & (bh.dlen = 0) then begin
  442.             oldstate := bh;
  443.             oldinused := inused;
  444.             realcrc := bh.crc;
  445.             BHGetByte(bh, inp, inlen, inused, err, h);
  446.             BHGetByte(bh, inp, inlen, inused, err, l);
  447.             if err = noErr then begin
  448.                 thecrc := BOR(BSL(h, 8), l);
  449.                 if thecrc <> realcrc then begin
  450.                     err := -8;
  451.                 end else begin
  452.                     eofork := true;
  453.                     eofile := not bh.datafork;
  454.                     bh.datafork := false;
  455.                     bh.dlen := bh.rlen;
  456.                 end;
  457.             end else if err = notEnoughData then begin
  458.                 err := noErr;
  459.                 bh := oldstate;
  460.                 inused := oldinused;
  461.             end;
  462.         end;
  463.         if err = notEnoughData then begin
  464.             err := noErr;
  465.         end;
  466.         BinHexDecodeChunk := err;
  467.     end;
  468.  
  469.     procedure StartupBinHex;
  470.         var
  471.             i: integer;
  472.     begin
  473.         mapbc := mapbc_hack;
  474.         binhex_start_string := binhex_start_string_hack;
  475.         for i := 0 to 255 do begin
  476.             map[i] := dud_byte;
  477.         end;
  478.         for i := 1 to length(mapbc) do begin
  479.             map[ord(mapbc[i])] := i - 1;
  480.         end;
  481.         StartupCalcCRC;
  482.     end;
  483.  
  484. end.